Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/picklist/picklist.pas

Pascal/Delphi Source File | 1995-12-22 | 9KB | 353 lines

unit Picklist;

{Copyright 1995 by Robert Fabiszak
  Free unrestricted use granted provided this copyright notice
  is maintained.

  PICKLIST is an enhanced list box control for Borland's Delphi
  product. Version 1.0. June, 1995}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, menus;

type

  TSelectedStyle = (psStandard, psCheckbox, psBoldText, psOwnerDraw);
  PTabArray = ^TTabArray;
  TTabArray = array[0..0] of integer;

  EInvalidTabStop = exception;

  TPickList = class(TCustomListBox)
  private
    { Private declarations }
    FUseTabs: boolean;
    FSelectedStyle: TSelectedStyle;
    FOnChange : TNotifyEvent;
    FLastSel : integer;
    FTabStops: TStrings;
    procedure Click; override;
  protected
    { Protected declarations }
    procedure SetUseTabStops(bUseTabs: boolean);
    procedure SetSelectedStyle(AStyle: TSelectedStyle);
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Change; virtual;
    procedure DrawCheckboxStyle(Index: integer; Rect: TRect;
      State: TOwnerDrawState);
    procedure DrawBoldStyle(Index: integer; Rect: TRect;
      State: TOwnerDrawState);
    function GetTabStops: string;
    procedure SetTabStops(sTabStops: string);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;
    procedure SelectAll;
    procedure ClearSelection;
    procedure DrawItem(Index: integer; Rect: TRect; State: TOwnerDrawState);
      override;
  published
    { Published declarations }
    property Align;
    property BorderStyle;
    property Color;
    property Columns;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ExtendedSelect;
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    property MultiSelect;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    {custom extensions}
    property UseTabStops: boolean read FUseTabs write SetUseTabStops
      default True;
    property SelectedStyle: TSelectedStyle read FSelectedStyle
      write SetSelectedStyle default psCheckbox;
    {NOTE: TabStops property measured in terms of average character widths}
    property TabStops: string read GetTabStops write SetTabStops;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

implementation

constructor TPickList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Style := lbOwnerDrawFixed;
  FLastSel := -1;
  FUseTabs := True;
  FSelectedStyle := psCheckbox;
  FTabStops := TStringList.Create;
end;


destructor TPickList.Destroy;
begin
  FTabStops.Free;
end;

procedure TPickList.SetUseTabStops(bUseTabs: boolean);
begin
  if FUseTabs <> bUseTabs then
  begin
    FUseTabs := bUseTabs;
    Invalidate
  end;
end;


procedure TPickList.SetSelectedStyle(AStyle: TSelectedStyle);
begin
  if FSelectedStyle <> AStyle then
  begin
    FSelectedStyle := AStyle;
    if AStyle = psStandard then
      Style := lbStandard
    else
      Style := lbOwnerDrawFixed;
    Invalidate;
  end;
end;

procedure TPickList.Change;
begin
  FLastSel := ItemIndex;
  if assigned(FOnChange) then FOnChange(self);
end;

procedure TPickList.Click;
begin
  inherited Click;
  if FLastSel <> ItemIndex then
     Change;
end;


procedure TPickList.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if FUseTabs then
    with Params do Style := Style or LBS_USETABSTOPS;
end;


procedure TPickList.SelectAll;
begin
  if MultiSelect or ExtendedSelect then
    SendMessage(Handle, LB_SETSEL, 1, -1);
end;

procedure TPickList.ClearSelection;
begin
  if MultiSelect or ExtendedSelect then
    SendMessage(Handle, LB_SETSEL, 0, -1);
end;


procedure TPickList.DrawItem(Index: integer; Rect: TRect; State:
  TOwnerDrawState);
begin
  case FSelectedStyle of
    psCheckbox: DrawCheckboxStyle(Index, Rect, State);
    psBoldText: DrawBoldStyle(Index, Rect, State);
    psStandard, psOwnerDraw: inherited DrawItem(Index, Rect, State);
  end;
end;


procedure TPickList.DrawCheckboxStyle(Index: integer; Rect: TRect;
  State: TOwnerDrawState);
var
  ch: array[0..255] of char;
  TabArray: PTabArray;
  i: integer;
  nTab: integer;
  Metrics: TTextMetric;
begin
  GetTextMetrics(Canvas.Handle, Metrics);
  GetMem(TabArray, FTabStops.Count * sizeof(integer));
  try
    for i := 0 to FTabStops.Count - 1 do
    begin
      try
        nTab := StrToInt(FTabStops[i]);  {if any non-integers, we'll raise exception}
      except
        on EConvertError do
          raise EInvalidTabStop.Create(FTabStops[i] + ' is an invalid tab stop');
      end;
      {convert tab stops from avg. character widths to device units}
      TabArray^[i] := nTab * Metrics.tmAveCharWidth;
    end;

    with Canvas do
    begin
      Brush.Color := Color;
      FillRect(Rect);
      {manually set these colors to override the color change when
      the item is focused}
      Font.Color := self.Font.Color;
      Pen.Color := self.Font.Color;
      Rectangle(Rect.Left + 2, Rect.Top + 1, Rect.Left + ItemHeight,
        Rect.Top + ItemHeight - 1);
      if odSelected in State then
      begin
        MoveTo(Rect.Left + 2, Rect.Top + 1);
        LineTo(Rect.Left + ItemHeight, Rect.Top + ItemHeight - 1);
        MoveTo(Rect.Left + ItemHeight - 1, Rect.Top + 1);
        LineTo(Rect.Left + 1, Rect.Top + ItemHeight - 1);
      end;
      if FUseTabs then
        TabbedTextOut(Handle, Rect.Left + ItemHeight + 4, Rect.Top,
          StrPCopy(ch, Items[Index]), Length(Items[Index]), FTabStops.Count,
          TabArray^, 0)
      else
        TextOut(Rect.Left + ItemHeight + 4, Rect.Top, Items[Index]);
    end;
  finally
    FreeMem(TabArray, FTabStops.Count * sizeof(integer));
  end;
end;


procedure TPickList.DrawBoldStyle(Index: integer; Rect: TRect;
  State: TOwnerDrawState);
var
  ch: array[0..255] of char;
  TabArray: PTabArray;
  i: integer;
  Metrics: TTextMetric;
  nTab: integer;
begin
  GetTextMetrics(Canvas.Handle, Metrics);
  GetMem(TabArray, FTabStops.Count * sizeof(integer));
  try
    for i := 0 to FTabStops.Count - 1 do
    begin
      try
        nTab := StrToInt(FTabStops[i]);  {if any non-integers, we'll raise exception}
      except
        on EConvertError do
          raise EInvalidTabStop.Create(FTabStops[i] + ' is an invalid tab stop');
      end;
      {convert tab stops from avg. character widths to device units}
      TabArray^[i] := nTab * Metrics.tmAveCharWidth;
    end;

    with Canvas do
    begin
      Brush.Color := Color;
      FillRect(Rect);
      {manually set these colors to override the color change when
      the item is focused}
      Font.Color := self.Font.Color;
      Pen.Color := self.Font.Color;
      if odSelected in State then
        Font.Style := Font.Style + [fsBold]
      else
        Font.Style := Font.Style - [fsBold];
      if FUseTabs then
        TabbedTextOut(Handle, Rect.Left + 2, Rect.Top, StrPCopy(ch, Items[Index]),
          Length(Items[Index]), FTabStops.Count, TabArray^, 0)
      else
        TextOut(Rect.Left + 2, Rect.Top, Items[Index]);
    end;
  finally
    FreeMem(TabArray, FTabStops.Count * sizeof(integer));
  end;
end;


function TPickList.GetTabStops: string;
var
  i: integer;
begin
  Result := '';
  for i := 0 to FTabStops.Count - 1 do
  begin
    Result := Result + FTabStops[i];
    if i < FTabStops.Count - 1 then
      Result := Result + ';';
  end;
end;


procedure TPickList.SetTabStops(sTabStops: string);
var
  sTemp: string;
  i: integer;
  nTab: integer;
begin
  FTabStops.Clear;     {get rid of current tab stops}
  if Length(sTabStops) = 0 then
    Exit;             {we're clearing the tab stops}
  sTemp := '';
  for i := 1 to Length(sTabStops) do
  begin
    if (sTabStops[i] = ';') and (i > 1) then
    begin
      try
        nTab := StrToInt(sTemp);  {if any non-integers, we'll raise exception}
      except
        on EConvertError do
          raise EInvalidTabStop.Create(sTemp + ' is an invalid tab stop');
      end;
      FTabStops.Add(sTemp);
      sTemp := '';
    end
    else
      sTemp := sTemp + sTabStops[i];
  end;
  {now make sure we add the final token}
  try
    nTab := StrToInt(sTemp);  {if any non-integers, we'll raise exception}
  except
    on EConvertError do
      raise EInvalidTabStop.Create(sTemp + ' is an invalid tab stop');
  end;
  FTabStops.Add(sTemp);
  Invalidate;
end;


procedure Register;
begin
  RegisterComponents('Extensions', [TPickList]);
end;

end.